home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol285 / display.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1987-03-15  |  23.9 KB  |  832 lines
  1. 100  REM DISPLAY Program.
  2. 110  REM Displays Genealogical Information
  3. 120  REM Copyright (c) 1983 - 1987 by: Melvin O. Duke.
  4. 130  DEFINT A-Z
  5. 600  REM Titles
  6. 610  TITLE$ = "Display Program"
  7. 620  TITLE$ = TITLE$ + " ON DISPLAY"
  8. 700  REM Terminate if not called from the Menu
  9. 710  IF DD.MENU$ <> "" THEN 770
  10. 720  COLOR 7,0 : KEY ON : CLS : LOCATE 15,1
  11. 730  PRINT "Cannot run the"
  12. 740  PRINT TITLE$
  13. 750  PRINT "Program, unless selected from the MENU"
  14. 760  END
  15. 770  REM OK
  16. 900  REM Dimension Statements
  17. 940  DIM PERS(15), CH(MAX.PER)
  18. 1000  REM Produce the first screen
  19. 1010  KEY ON : CLS : KEY OFF
  20. 1020  REM Draw the outer double box
  21. 1030  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 1300
  22. 1040  REM Find the title location
  23. 1050  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  24. 1060  REM Draw the title box
  25. 1070  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 1500
  26. 1080  REM Print the title
  27. 1090  LOCATE 4,TITLE.POS : PRINT TITLE$
  28. 1100  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  29. 1230  REM Draw the Copyright box
  30. 1240  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 1300
  31. 1250  REM Print the Copyright
  32. 1260  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  33. 1270  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  34. 1280  GOTO 1700
  35. 1300  REM subroutine to print a double box
  36. 1310  COLOR P
  37. 1320  FOR I = R1 + 1 TO R2 - 1
  38. 1330   LOCATE I, C1 : PRINT CHR$(186);
  39. 1340   LOCATE I, C2 : PRINT CHR$(186);
  40. 1350  NEXT I
  41. 1360   LOCATE R1, C1+1 : PRINT STRING$(C2-C1-1,205);
  42. 1390   LOCATE R2, C1+1 : PRINT STRING$(C2-C1-1,205);
  43. 1400   LOCATE R1, C1 : PRINT CHR$(201);
  44. 1410   LOCATE R1, C2 : PRINT CHR$(187);
  45. 1420   LOCATE R2, C1 : PRINT CHR$(200);
  46. 1430   LOCATE R2, C2 : PRINT CHR$(188);
  47. 1440  COLOR W
  48. 1450  RETURN
  49. 1500  REM subroutine to print a single box
  50. 1510  COLOR B
  51. 1520  FOR I = R1 + 1 TO R2 - 1
  52. 1530   LOCATE I, C1 : PRINT CHR$(179);
  53. 1540   LOCATE I, C2 : PRINT CHR$(179);
  54. 1550  NEXT I
  55. 1560   LOCATE R1, C1+1 : PRINT STRING$(C2-C1-1,196);
  56. 1590   LOCATE R2, C1+1 : PRINT STRING$(C2-C1-1,196);
  57. 1600   LOCATE R1, C1 : PRINT CHR$(218);
  58. 1610   LOCATE R1, C2 : PRINT CHR$(191);
  59. 1620   LOCATE R2, C1 : PRINT CHR$(192);
  60. 1630   LOCATE R2, C2 : PRINT CHR$(217);
  61. 1640  COLOR W
  62. 1650  RETURN
  63. 1700  REM ask user to press a key to continue
  64. 1710  LOCATE 25,1
  65. 1720  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  66. 1730  K$ = INKEY$ : IF K$ = "" THEN 1730
  67. 1740  KEY ON : CLS
  68. 1750  GOTO 3530
  69. 2000  REM DISPLAY Program Starts Here.
  70. 2010  REM Draw the form on the display
  71. 2020  R1= 1 : C1= 1 : R2=21 : C2=79: GOSUB 1300 'Double box
  72. 2030  R1= 3 : C1= 1 : R2= 3 : C2=79: GOSUB 3210 'Horizontal Double
  73. 2040  LOCATE 2,3 : PRINT "Pedigree Chart for:"
  74. 2050  LOCATE 4,68 : COLOR N : PRINT "Birthdate:" : COLOR W
  75. 2060  LOCATE 12, 3 : I = 1 : GOSUB 2470
  76. 2070  LOCATE  8,11 : COLOR B : PRINT CHR$(218)+CHR$(196);
  77. 2080  LOCATE  9,11 : PRINT CHR$(179);
  78. 2090  LOCATE 10,11 : PRINT CHR$(179);
  79. 2100  LOCATE 11,11 : PRINT CHR$(179);
  80. 2110  LOCATE  8,13 : I = 2 : GOSUB 2510
  81. 2120  LOCATE 16,11 : COLOR B : PRINT CHR$(192)+CHR$(196);
  82. 2130  LOCATE 13,11 : PRINT CHR$(179);
  83. 2140  LOCATE 14,11 : PRINT CHR$(179);
  84. 2150  LOCATE 15,11 : PRINT CHR$(179);
  85. 2160  LOCATE 16,13 : I = 3 : GOSUB 2510
  86. 2170  LOCATE  6,21 : COLOR B : PRINT CHR$(218)+CHR$(196);
  87. 2180  LOCATE  7,21 : PRINT CHR$(179);
  88. 2190  LOCATE  6,23 : I = 4 : GOSUB 2540
  89. 2200  LOCATE 10,21 : COLOR B : PRINT CHR$(192)+CHR$(196);
  90. 2210  LOCATE  9,21 : PRINT CHR$(179);
  91. 2220  LOCATE 10,23 : I = 5 : GOSUB 2540
  92. 2230  LOCATE 14,21 : COLOR B : PRINT CHR$(218)+CHR$(196);
  93. 2240  LOCATE 15,21 : PRINT CHR$(179);
  94. 2250  LOCATE 14,23 : I = 6 : GOSUB 2540
  95. 2260  LOCATE 18,21 : COLOR B : PRINT CHR$(192)+CHR$(196);
  96. 2270  LOCATE 17,21 : PRINT CHR$(179);
  97. 2280  LOCATE 18,23 : I = 7 : GOSUB 2540
  98. 2290  LOCATE  5,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  99. 2300  LOCATE  5,33 : I = 8 : GOSUB 2570
  100. 2310  LOCATE  7,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  101. 2320  LOCATE  7,33 : I = 9 : GOSUB 2570
  102. 2330  LOCATE  9,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  103. 2340  LOCATE  9,33 : I = 10 : GOSUB 2570
  104. 2350  LOCATE 11,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  105. 2360  LOCATE 11,33 : I = 11 : GOSUB 2570
  106. 2370  LOCATE 13,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  107. 2380  LOCATE 13,33 : I = 12 : GOSUB 2570
  108. 2390  LOCATE 15,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  109. 2400  LOCATE 15,33 : I = 13 : GOSUB 2570
  110. 2410  LOCATE 17,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  111. 2420  LOCATE 17,33 : I = 14 : GOSUB 2570
  112. 2430  LOCATE 19,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  113. 2440  LOCATE 19,33 : I = 15 : GOSUB 2570
  114. 2450  COLOR W,K
  115. 2460  RETURN
  116. 2470  REM Routine to print the lines
  117. 2480  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  118. 2490  COLOR B,K : PRINT STRING$(62,95);
  119. 2500  RETURN
  120. 2510  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  121. 2520  COLOR B,K : PRINT STRING$(52,95);
  122. 2530  RETURN
  123. 2540  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  124. 2550  COLOR B,K : PRINT STRING$(42,95);
  125. 2560  RETURN
  126. 2570  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  127. 2580  COLOR B,K : PRINT STRING$(32,95); : COLOR W,K
  128. 2590  RETURN
  129. 2600  REM Draw the Personal Information Chart
  130. 2610  KEY OFF
  131. 2620  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 1300  'Double box
  132. 2630  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 3210  'Horizontal double
  133. 2640  LOCATE 2,3 : PRINT "Personal Information for:"
  134. 2650  R1 = 3 : C1 = 40 : R2 = 21 : C2 = 40 : GOSUB 3350  'Vertical Double
  135. 2660  LOCATE 4,3 : COLOR N : PRINT "Person:";
  136. 2670  LOCATE 5,3 : COLOR O : PRINT "Record-no.:";
  137. 2680  LOCATE 6,3 : PRINT "Surname:";
  138. 2690  LOCATE 7,3 : PRINT "Given-names:";
  139. 2700  LOCATE 8,3 : PRINT "Sex:";
  140. 2710  R1 = 9 : C1 = 1 : R2 =11 : C2 = 40 : GOSUB 3210  'Horizontal Double
  141. 2720  LOCATE 10,3 : COLOR N : PRINT "Male Parent:";
  142. 2730  LOCATE 11,3 : COLOR O : PRINT "Record-no.:";
  143. 2740  LOCATE 12,3 : PRINT "Surname:";
  144. 2750  LOCATE 13,3 : PRINT "Given-names:";
  145. 2760  LOCATE 14,3 : PRINT "Birth-date:";
  146. 2770  R1 = 15 : C1 = 1 : R2 = 15 : C2 = 40 : GOSUB 3280  'Horizontal Single
  147. 2780  LOCATE 16,3 : COLOR N : PRINT "Female Parent:";
  148. 2790  LOCATE 17,3 : COLOR O : PRINT "Record-no.:";
  149. 2800  LOCATE 18,3 : PRINT "Surname:";
  150. 2810  LOCATE 19,3 : PRINT "Given-names:";
  151. 2820  LOCATE 20,3 : PRINT "Birth-date:";
  152. 2830  LOCATE 4,42 : COLOR N : PRINT "Person's Vital Statistics:";
  153. 2840  LOCATE 6,42 : COLOR O : PRINT "Birth-date:";
  154. 2850  LOCATE 7,42 : PRINT "Birth-city:";
  155. 2860  LOCATE 8,42 : PRINT "Birth-county:";
  156. 2870  LOCATE 9,42 : PRINT "Birth-state:";
  157. 2880  LOCATE 11,42 : PRINT "Death-date:";
  158. 2890  LOCATE 12,42 : PRINT "Death-city:";
  159. 2900  LOCATE 13,42 : PRINT "Death-county:";
  160. 2910  LOCATE 14,42 : PRINT "Death-state:";
  161. 2920  LOCATE 16,42 : PRINT "Burial-date:";
  162. 2930  LOCATE 17,42 : PRINT "Burial-city:";
  163. 2940  LOCATE 18,42 : PRINT "Burial-county:";
  164. 2950  LOCATE 19,42 : PRINT "Burial-state:"; : COLOR W,K
  165. 2960  RETURN
  166. 2970  REM draw a Family Group Sheet
  167. 2980  KEY OFF
  168. 2990  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 1300  'Double box
  169. 3000  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 3210  'Double Horizontal
  170. 3010  LOCATE 2,3 : PRINT "Family Group Record";
  171. 3020  LOCATE 2,64 : PRINT "Marriage:";
  172. 3030  LOCATE 4,3 : COLOR O : PRINT "Father:";
  173. 3040  LOCATE 4,56 : PRINT "Birthdate:";
  174. 3050  LOCATE 5,3 : PRINT "Mother:";
  175. 3060  LOCATE 5,56 : PRINT "Birthdate:";
  176. 3070  R1 = 6 : C1 = 1 : R2 = 6 : C2 = 79 : GOSUB 3280  'Single Horizontal
  177. 3080  LOCATE 7,3 : COLOR O : PRINT "Marriage Date:";
  178. 3090  LOCATE 7,35 : PRINT "Location:";
  179. 3100  R1 = 8 : C1 = 1 : R2 = 8 : C2 = 79 : GOSUB 3210  'Double Horizontal
  180. 3110  R1 = 8 : C1 = 5 : R2 = 21 : C2 = 5 : GOSUB 3440  'Single Vertical
  181. 3120  R1 = 8 : C1 = 7 : R2 = 21 : C2 = 7 : GOSUB 3440  'Single Vertical
  182. 3130  R1 = 8 : C1 = 40 : R2 = 21 : C2 = 40 : GOSUB 3440  'Single Vertical
  183. 3140  LOCATE 9,2 : COLOR N : PRINT "No.";
  184. 3150  LOCATE 9,6 : PRINT "S";
  185. 3160  LOCATE 9,8 : PRINT "Children:";
  186. 3170  LOCATE 9,41 : PRINT "Birthdate:";
  187. 3180  R1 = 8 : C1 = 52 : R2 = 21 : C2 = 52 : GOSUB 3440  'Single Vertical
  188. 3190  LOCATE 9,53 : COLOR N : PRINT "Birth Location:"; : COLOR W
  189. 3200  RETURN
  190. 3210  REM Subroutine to draw a double horizontal line.  Attach to double.
  191. 3220  COLOR P
  192. 3230   LOCATE R1,C1+1 : PRINT STRING$(C2-C1-1,205)
  193. 3240  LOCATE R1,C1 : PRINT CHR$(204);
  194. 3250  LOCATE R1,C2 : PRINT CHR$(185);
  195. 3260  COLOR W
  196. 3270  RETURN
  197. 3280  REM Subroutine to draw a single horizontal line.  Attach to double.
  198. 3290  COLOR P
  199. 3300   LOCATE R1,C1+1 : PRINT STRING$(C2-C1-1,196)
  200. 3310  LOCATE R1,C1 : PRINT CHR$(199);
  201. 3320  LOCATE R1,C2 : PRINT CHR$(182);
  202. 3330  COLOR W
  203. 3340  RETURN
  204. 3350  REM Subroutine to draw a double vertical line.  Attach to double.
  205. 3360  COLOR P
  206. 3370  FOR I = R1 + 1 TO R2 - 1
  207. 3380   LOCATE I,C1 : PRINT CHR$(186);
  208. 3390  NEXT I
  209. 3400  LOCATE R1,C1 : PRINT CHR$(203);
  210. 3410  LOCATE R2,C1 : PRINT CHR$(202);
  211. 3420  COLOR W
  212. 3430  RETURN
  213. 3440  REM Subroutine to draw a single vertical line.  Attach to double.
  214. 3450  COLOR P
  215. 3460  FOR I = R1 + 1 TO R2 - 1
  216. 3470   LOCATE I,C1 : PRINT CHR$(179);
  217. 3480  NEXT I
  218. 3490  LOCATE R1,C1 : PRINT CHR$(209);
  219. 3500  LOCATE R2,C1 : PRINT CHR$(207);
  220. 3510  COLOR W
  221. 3520  RETURN
  222. 3530  REM Program begins here
  223. 3540  REM By:  Melvin O. Duke.
  224. 3550  REM Read the Parent/Child Index
  225. 3560  OPEN DD.PCIDX$+"pcindex" FOR INPUT AS #1
  226. 3570  KEY OFF
  227. 3580  LOCATE 4,1 : PRINT "Open the Parent/Child Index";
  228. 3590  INPUT #1, PC.COUNT
  229. 3600  DIM PA.ID(PC.COUNT), CH.ID(PC.COUNT)
  230. 3610  FOR I = 1 TO PC.COUNT
  231. 3620  LOCATE 5,1 : PRINT "Reading Index Record #:";I;
  232. 3630   INPUT #1, PA.ID(I), CH.ID(I)
  233. 3640  NEXT I
  234. 3650  CLOSE #1
  235. 3660  REM Read the Marriage Index
  236. 3670  LOCATE 7,1 : PRINT "Open the Marriage Index";
  237. 3680  OPEN DD.MARIDX$+"mindex" FOR INPUT AS #2
  238. 3690  INPUT #2, M.COUNT
  239. 3700  DIM PERS.NO(M.COUNT), M.NO(M.COUNT)
  240. 3710  FOR I = 1 TO M.COUNT
  241. 3720  LOCATE 8,1 : PRINT "Reading Marriage Index Record #:";I:
  242. 3730   INPUT #2,PERS.NO(I), M.NO(I)
  243. 3740  NEXT I
  244. 3750  CLOSE #2
  245. 3760  REM Open the Persons File
  246. 3770  LOCATE 10,1 : PRINT "Open the Persons File"
  247. 3780  OPEN DD.PERS$+"persfile" AS #1 LEN = 256
  248. 3790  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  249. 3800  REM open the Marriages File
  250. 3810  LOCATE 12,1 : PRINT "Open the Marriage File"
  251. 3820  OPEN DD.MARR$+"marrfile" AS #2 LEN = 128
  252. 3830  FIELD 2, 5 AS M1$, 5 AS M2$, 5 AS M3$, 5 AS M4$, 11 AS M5$, 18 AS M6$, 16 AS M7$, 16 AS M8$, 45 AS M9$
  253. 3840  REM Open the Ordinance File
  254. 3850  IF DD.ORD$ = "no" THEN 3890
  255. 3860  LOCATE 14,1 : PRINT "Open the Ordinances File";
  256. 3870  OPEN DD.ORD$+"ordfile" AS #3 LEN = 256
  257. 3880  FIELD 3,5ASO1$,11ASO2$,11ASO3$,11ASO4$,5ASO5$,5ASO6$,11ASO7$,11ASO8$,11ASO9$,11ASO10$,11ASO11$,5ASO12$,11ASO13$,11ASO14$,11ASO15$,11ASO16$,11ASO17$,11ASO18$,11ASO19$,11ASO20$,11ASO21$,11ASO22$,11ASO23$,26ASO24$
  258. 3890  REM Obtain a Person Record from the User
  259. 3900  LOCATE 20,1 : PRINT SPACE$(79);: LOCATE 20,1
  260. 3910  LINE INPUT "Enter the Record-number of a Person (0 to quit): ";REPLY$
  261. 3920  IF REPLY$ = "0" THEN 9350
  262. 3930  PERS(1) = VAL(REPLY$)
  263. 3940  IF PERS(1) < 1 OR PERS(1) > MAX.PER THEN KEY ON : CLS : KEY OFF : LOCATE 19,1 : PRINT "Number is out of range"; : GOTO 3890
  264. 3950  REM Obtain the information about a person
  265. 3960  GET #1, PERS(1)
  266. 3970  KEY ON : CLS
  267. 3980  GOSUB 4550  'Extract Personal Information
  268. 3990  GOSUB 2600 'Draw the form
  269. 4000  LOCATE 2,30 : COLOR W : PRINT LEFT$(T3$ + " " + T2$,35);
  270. 4010  LOCATE 2,66 : PRINT "Person:";T1
  271. 4020  LOCATE 5,16 : COLOR G : PRINT T1
  272. 4030  LOCATE 6,16 : PRINT T2$;
  273. 4040  LOCATE 7,16 : PRINT LEFT$(T3$,24);
  274. 4050  LOCATE 8,16 : PRINT T4$;
  275. 4060  LOCATE 6,57 : PRINT T8$;
  276. 4070  LOCATE 7,57 : PRINT T9$;
  277. 4080  LOCATE 8,57 : PRINT T10$;
  278. 4090  LOCATE 9,57 : PRINT T11$;
  279. 4100  LOCATE 11,57 : PRINT T12$;
  280. 4110  LOCATE 12,57 : PRINT T13$;
  281. 4120  LOCATE 13,57 : PRINT T14$;
  282. 4130  LOCATE 14,57 : PRINT T15$;
  283. 4140  LOCATE 16,57 : PRINT T16$;
  284. 4150  LOCATE 17,57 : PRINT T17$;
  285. 4160  LOCATE 18,57 : PRINT T18$;
  286. 4170  LOCATE 19,57 : PRINT T19$;
  287. 4180  PERS(2) = T6
  288. 4190  PERS(3) = T7
  289. 4200  COLOR W
  290. 4210  REM Check if Male Parent is known
  291. 4220  IF PERS(2) = 0 THEN GOSUB 4890 : GOTO 4250
  292. 4230  GET #1, PERS(2)
  293. 4240  GOSUB 4550  'Extract
  294. 4250  LOCATE 11,16 : COLOR G : PRINT T1;
  295. 4260  LOCATE 12,16 : PRINT T2$;
  296. 4270  LOCATE 13,16 : PRINT LEFT$(T3$,24);
  297. 4280  LOCATE 14,16 : PRINT T8$;
  298. 4290  COLOR W
  299. 4300  REM Check if Female Parent is known
  300. 4310  IF PERS(3) = 0 THEN GOSUB 4890 : GOTO 4340
  301. 4320  GET #1, PERS(3)
  302. 4330  GOSUB 4550  'Extract
  303. 4340  LOCATE 17,16 : COLOR G : PRINT T1;
  304. 4350  LOCATE 18,16 : PRINT T2$;
  305. 4360  LOCATE 19,16 : PRINT LEFT$(T3$,24);
  306. 4370  LOCATE 20,16 : PRINT T8$;
  307. 4380  COLOR W,K : LOCATE 23,1 : PRINT SPACE$(79);
  308. 4390  LOCATE 24,1 : PRINT SPACE$(79);
  309. 4400  LOCATE 24,1 : PRINT "(Possible Requests:  ps, pc, fg, ";
  310. 4410  IF DD.ORD$ = "no" THEN 4430
  311. 4420  PRINT "o, ";
  312. 4430  PRINT "p1...pn, m1...mn, q)";
  313. 4440  LOCATE 23,1
  314. 4450  LINE INPUT "Type a Request.  Then press the 'enter' key.: "; REPLY$
  315. 4460  IF REPLY$ = "ps" OR REPLY$ = "PS" THEN GOSUB 7950 : GOTO 4380
  316. 4470  IF REPLY$ = "pc" OR REPLY$ = "PC" THEN 5090  'Pedigree Chart
  317. 4480  IF REPLY$ = "fg" OR REPLY$ = "FG" THEN 6600  'Family Group
  318. 4490  IF DD.ORD$ = "no" THEN 4510
  319. 4500  IF REPLY$ = "o" OR REPLY$ = "O" THEN 8090  'Ordinances
  320. 4510  IF LEFT$(REPLY$,1) = "p" OR LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : KEY ON : CLS : KEY OFF : GOTO 3940
  321. 4520  IF LEFT$(REPLY$,1) = "m" OR LEFT$(REPLY$,1) = "M" THEN 9220
  322. 4530  IF LEFT$(REPLY$,1) = "q" OR LEFT$(REPLY$,1) = "Q" THEN 9350
  323. 4540  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 4380
  324. 4550  REM Routine to Extract Personal Information
  325. 4560  T1! = CVS(F1$) : T1 = T1!
  326. 4570  T2$ = F2$
  327. 4580  FOR J = 1 TO LEN(F2$) -1
  328. 4590   IF RIGHT$(T2$,1)=" " THEN T2$ = LEFT$(T2$,LEN(T2$)-1) ELSE J = LEN(F2$)-1
  329. 4600  NEXT J
  330. 4610  T3$ = F3$
  331. 4620  FOR J = 1 TO LEN(F3$) -1
  332. 4630   IF RIGHT$(T3$,1)=" " THEN T3$ = LEFT$(T3$,LEN(T3$)-1) ELSE J = LEN(F3$)-1
  333. 4640  NEXT J
  334. 4650  T4$ = F4$
  335. 4660  IF LEFT$(T4$,1) = MALE.LTR$   THEN T4$ = MALE.SEX$
  336. 4670  IF LEFT$(T4$,1) = FEMALE.LTR$ THEN T4$ = FEMALE.SEX$
  337. 4680  T6! = CVS(F6$) : T6 = T6!
  338. 4690  T7! = CVS(F7$) : T7 = T7!
  339. 4700  T8$ = F8$
  340. 4710  T9$ = F9$
  341. 4720  FOR J = 1 TO LEN(F9$) -1
  342. 4730   IF RIGHT$(T9$,1)=" " THEN T9$ = LEFT$(T9$,LEN(T9$)-1) ELSE J = LEN(F9$)-1
  343. 4740  NEXT J
  344. 4750  T10$ = F10$
  345. 4760  T11$ = F11$
  346. 4770  FOR J = 1 TO LEN(F11$) -1
  347. 4780   IF RIGHT$(T11$,1)=" " THEN T11$ = LEFT$(T11$,LEN(T11$)-1) ELSE J = LEN(F11$)-1
  348. 4790  NEXT J
  349. 4800  T12$ = F12$
  350. 4810  T13$ = F13$
  351. 4820  T14$ = F14$
  352. 4830  T15$ = F15$
  353. 4840  T16$ = F16$
  354. 4850  T17$ = F17$
  355. 4860  T18$ = F18$
  356. 4870  T19$ = F19$
  357. 4880  RETURN
  358. 4890  REM Blank out a Record
  359. 4900  T1 = 0
  360. 4910  T2$ = ""
  361. 4920  T3$ = ""
  362. 4930  T4$ = ""
  363. 4940  T6 = 0
  364. 4950  T7 = 0
  365. 4960  T8$ = ""
  366. 4970  T9$ = ""
  367. 4980  T10$ = ""
  368. 4990  T11$ = ""
  369. 5000  T12$ = ""
  370. 5010  T13$ = ""
  371. 5020  T14$ = ""
  372. 5030  T15$ = ""
  373. 5040  T16$ = ""
  374. 5050  T17$ = ""
  375. 5060  T18$ = ""
  376. 5070  T19$ = ""
  377. 5080  RETURN
  378. 5090  REM Routine to Produce a Pedigree Chart
  379. 5100  KEY ON : CLS : KEY OFF
  380. 5110  GOSUB 2000 'Draw the Chart
  381. 5120  GET #1, PERS(1)
  382. 5130  GOSUB 4550  'Extract the Person
  383. 5140  LOCATE 2,23 : COLOR W : PRINT LEFT$(T3$ + " " + T2$,42);
  384. 5150  LOCATE 2,66 : PRINT "Person:"; PERS(1);
  385. 5160  THIS.PERS = PERS(1) : GOSUB 9430
  386. 5170  LOCATE 12,6 : COLOR G : PRINT LEFT$(VALUE$,61);
  387. 5180  LOCATE 12,68 : PRINT T8$;
  388. 5190  PERS(2) = T6
  389. 5200  PERS(3) = T7
  390. 5210  REM Get 11
  391. 5220  IF PERS(2) = 0 THEN GOSUB 4890 : GOTO 5280
  392. 5230  GET #1, PERS(2)
  393. 5240  GOSUB 4550  'Extract
  394. 5250  THIS.PERS = PERS(2) : GOSUB 9430
  395. 5260  LOCATE 8,16 : PRINT LEFT$(VALUE$,51);
  396. 5270  LOCATE 8,68 : PRINT T8$;
  397. 5280  PERS(4) = T6
  398. 5290  PERS(5) = T7
  399. 5300  REM Get 10
  400. 5310  IF PERS(3) = 0 THEN GOSUB 4890 : GOTO 5370
  401. 5320  GET #1, PERS(3)
  402. 5330  GOSUB 4550  'Extract
  403. 5340  THIS.PERS = PERS(3): GOSUB 9430
  404. 5350  LOCATE 16,16 : PRINT LEFT$(VALUE$,51);
  405. 5360  LOCATE 16,68 : PRINT T8$;
  406. 5370  PERS(6) = T6
  407. 5380  PERS(7) = T7
  408. 5390  REM Get 111
  409. 5400  IF PERS(4) = 0 THEN GOSUB 4890 : GOTO 5460
  410. 5410  GET #1, PERS(4)
  411. 5420  GOSUB 4550  'Extract
  412. 5430  THIS.PERS = PERS(4): GOSUB 9430
  413. 5440  LOCATE 6,26 : PRINT LEFT$(VALUE$,41);
  414. 5450  LOCATE 6,68 : PRINT T8$;
  415. 5460  PERS(8) = T6
  416. 5470  PERS(9) = T7
  417. 5480  REM Get 110
  418. 5490  IF PERS(5) = 0 THEN GOSUB 4890 : GOTO 5550
  419. 5500  GET #1, PERS(5)
  420. 5510  GOSUB 4550  'Extract
  421. 5520  THIS.PERS = PERS(5): GOSUB 9430
  422. 5530  LOCATE 10,26 : PRINT LEFT$(VALUE$,41);
  423. 5540  LOCATE 10,68 : PRINT T8$;
  424. 5550  PERS(10) = T6
  425. 5560  PERS(11) = T7
  426. 5570  REM Get 101
  427. 5580  IF PERS(6) = 0 THEN GOSUB 4890 : GOTO 5640
  428. 5590  GET #1, PERS(6)
  429. 5600  GOSUB 4550  'Extract
  430. 5610  THIS.PERS = PERS(6): GOSUB 9430
  431. 5620  LOCATE 14,26 : PRINT LEFT$(VALUE$,41);
  432. 5630  LOCATE 14,68 : PRINT T8$;
  433. 5640  PERS(12) = T6
  434. 5650  PERS(13) = T7
  435. 5660  REM Get 100
  436. 5670  IF PERS(7) = 0 THEN GOSUB 4890 : GOTO 5730
  437. 5680  GET #1, PERS(7)
  438. 5690  GOSUB 4550  'Extract
  439. 5700  THIS.PERS = PERS(7): GOSUB 9430
  440. 5710  LOCATE 18,26 : PRINT LEFT$(VALUE$,41);
  441. 5720  LOCATE 18,68 : PRINT T8$;
  442. 5730  PERS(14) = T6
  443. 5740  PERS(15) = T7
  444. 5750  REM Get 1111
  445. 5760  IF PERS(8) = 0 THEN GOSUB 4890 : GOTO 5820
  446. 5770  GET #1, PERS(8)
  447. 5780  GOSUB 4550  'Extract
  448. 5790  THIS.PERS = PERS(8): GOSUB 9430
  449. 5800  LOCATE  5,36 : PRINT LEFT$(VALUE$,31);
  450. 5810  LOCATE  5,68 : PRINT T8$;
  451. 5820  REM
  452. 5830  REM Get 1110
  453. 5840  IF PERS(9) = 0 THEN GOSUB 4890 : GOTO 5900
  454. 5850  GET #1, PERS(9)
  455. 5860  GOSUB 4550  'Extract
  456. 5870  THIS.PERS = PERS(9): GOSUB 9430
  457. 5880  LOCATE  7,36 : PRINT LEFT$(VALUE$,31);
  458. 5890  LOCATE  7,68 : PRINT T8$;
  459. 5900  REM
  460. 5910  REM Get 1101
  461. 5920  IF PERS(10) = 0 THEN GOSUB 4890 : GOTO 5980
  462. 5930  GET #1, PERS(10)
  463. 5940  GOSUB 4550  'Extract
  464. 5950  THIS.PERS = PERS(10): GOSUB 9430
  465. 5960  LOCATE  9,36 : PRINT LEFT$(VALUE$,31);
  466. 5970  LOCATE  9,68 : PRINT T8$;
  467. 5980  REM
  468. 5990  REM Get 1100
  469. 6000  IF PERS(11) = 0 THEN GOSUB 4890 : GOTO 6060
  470. 6010  GET #1, PERS(11)
  471. 6020  GOSUB 4550  'Extract
  472. 6030  THIS.PERS = PERS(11): GOSUB 9430
  473. 6040  LOCATE 11,36 : PRINT LEFT$(VALUE$,31);
  474. 6050  LOCATE 11,68 : PRINT T8$;
  475. 6060  REM
  476. 6070  REM Get 1011
  477. 6080  IF PERS(12) = 0 THEN GOSUB 4890 : GOTO 6140
  478. 6090  GET #1, PERS(12)
  479. 6100  GOSUB 4550  'Extract
  480. 6110  THIS.PERS = PERS(12): GOSUB 9430
  481. 6120  LOCATE 13,36 : PRINT LEFT$(VALUE$,31);
  482. 6130  LOCATE 13,68 : PRINT T8$;
  483. 6140  REM
  484. 6150  REM Get 1010
  485. 6160  IF PERS(13) = 0 THEN GOSUB 4890 : GOTO 6220
  486. 6170  GET #1, PERS(13)
  487. 6180  GOSUB 4550  'Extract
  488. 6190  THIS.PERS = PERS(13): GOSUB 9430
  489. 6200  LOCATE 15,36 : PRINT LEFT$(VALUE$,31);
  490. 6210  LOCATE 15,68 : PRINT T8$;
  491. 6220  REM
  492. 6230  REM Get 1001
  493. 6240  IF PERS(14) = 0 THEN GOSUB 4890 : GOTO 6300
  494. 6250  GET #1, PERS(14)
  495. 6260  GOSUB 4550  'Extract
  496. 6270  THIS.PERS = PERS(14): GOSUB 9430
  497. 6280  LOCATE 17,36 : PRINT LEFT$(VALUE$,31);
  498. 6290  LOCATE 17,68 : PRINT T8$;
  499. 6300  REM
  500. 6310  REM Get 1000
  501. 6320  IF PERS(15) = 0 THEN GOSUB 4890 : GOTO 6380
  502. 6330  GET #1, PERS(15)
  503. 6340  GOSUB 4550  'Extract
  504. 6350  THIS.PERS = PERS(15): GOSUB 9430
  505. 6360  LOCATE 19,36 : PRINT LEFT$(VALUE$,31);
  506. 6370  LOCATE 19,68 : PRINT T8$;
  507. 6380  COLOR W
  508. 6390  LOCATE 23,1 : PRINT SPACE$(79);
  509. 6400  LOCATE 24,1 : PRINT SPACE$(79);
  510. 6410  LOCATE 24,1 : PRINT "(Possible Requests:  ps, pc, fg, l1...ln, p1...pn, m1...mn, q)";
  511. 6420  LOCATE 23,1
  512. 6430  LINE INPUT "Type a Request.  Then press the 'enter' key.: "; REPLY$
  513. 6440  IF REPLY$ = "ps" OR REPLY$ = "PS" THEN GOSUB 7950 : GOTO 6390
  514. 6450  IF REPLY$ = "pc" OR REPLY$ = "PC" THEN 5090
  515. 6460  IF REPLY$ = "fg" OR REPLY$ = "FG" THEN 6600
  516. 6470  IF LEFT$(REPLY$,1) = "l" OR LEFT$(REPLY$,1) = "L" THEN 6480 ELSE 6560
  517. 6480  WHO = (VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)))
  518. 6490  IF WHO < 1 OR WHO > 15 THEN 6500 ELSE 6550
  519. 6500  KEY ON : CLS : KEY OFF
  520. 6510  LOCATE 20,1 : PRINT "Line-number is out of range"
  521. 6520  LOCATE 22,1 : PRINT "Press any key to continue"
  522. 6530  A$ = INKEY$ : IF A$ = "" THEN 6530
  523. 6540  GOTO 3940
  524. 6550  PERS(1) = PERS(WHO) : GOTO 3940
  525. 6560  IF LEFT$(REPLY$,1) = "p" OR LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 3940
  526. 6570  IF LEFT$(REPLY$,1) = "m" OR LEFT$(REPLY$,1) = "M" THEN 9220
  527. 6580  IF LEFT$(REPLY$,1) = "q" OR LEFT$(REPLY$,1) = "Q" THEN 9350
  528. 6590  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 6390
  529. 6600  REM Routine to Produce a Family Group Record
  530. 6610  KEY ON : CLS
  531. 6620  GOSUB 2970  'Draw the form
  532. 6630  REM search the marriage index for the Person's Marriage
  533. 6640  FOUND = 0
  534. 6650  REM Establish Skip-ahead Start-value and Delta
  535. 6660  START.AT = 1 : DELTA = INT(M.COUNT/10) : IF DELTA = 0 THEN 6710
  536. 6670  REM Add delta and test if too far
  537. 6680  START.AT = START.AT + DELTA
  538. 6690  IF START.AT > 9 * DELTA THEN 6710
  539. 6700  IF PERS(1) > PERS.NO(START.AT) THEN 6680
  540. 6710  START.AT = START.AT - DELTA
  541. 6720  REM Search Routine
  542. 6730  FOR L = START.AT TO M.COUNT
  543. 6740   IF PERS(1) > PERS.NO(L) THEN 6800
  544. 6750   IF PERS(1) < PERS.NO(L) THEN L = M.COUNT : GOTO 6800
  545. 6760   REM found a Marriage
  546. 6770   FOUND = 1
  547. 6780   GET #2, M.NO(L)
  548. 6790   L = M.COUNT
  549. 6800  NEXT L
  550. 6810  IF FOUND = 1 THEN 6870
  551. 6820  REM No marriage found
  552. 6830  LOCATE 22,1 : COLOR W,K : PRINT "No Marriage Found";
  553. 6840  LOCATE 23,1 : PRINT "Press any key to continue";
  554. 6850  A$ = INKEY$ : IF A$ = "" THEN 6850
  555. 6860  KEY ON : CLS : KEY OFF : GOTO 3950
  556. 6870  REM extract Information from the Marriage Record
  557. 6880  TT1! = CVS(M1$) : TT1 = TT1!
  558. 6890  IF TT1 < 1 THEN 6820
  559. 6900  TT2! = CVS(M2$) : TT2 = TT2!
  560. 6910  TT3! = CVS(M3$) : TT3 = TT3!
  561. 6920  TT5$ = M5$
  562. 6930  TT6$ = M6$
  563. 6940  REM Right-trim
  564. 6950  FOR J = 1 TO LEN(M6$) -1
  565. 6960   IF RIGHT$(TT6$,1)=" " THEN TT6$ = LEFT$(TT6$,LEN(TT6$)-1) ELSE J = LEN(M6$)-1
  566. 6970  NEXT J
  567. 6980  TT7$ = M7$
  568. 6990  TT8$ = M8$
  569. 7000  REM Right-trim
  570. 7010  FOR J = 1 TO LEN(M8$) -1
  571. 7020   IF RIGHT$(TT8$,1)=" " THEN TT8$ = LEFT$(TT8$,LEN(TT8$)-1) ELSE J = LEN(M8$)-1
  572. 7030  NEXT J
  573. 7040  TT9$ = M9$
  574. 7050  REM print the Marriage Information
  575. 7060  LOCATE 2,73 : COLOR W : PRINT TT1
  576. 7070  LOCATE 7,18 : COLOR G : PRINT TT5$
  577. 7080  IF TT6$ = " " AND TT8$ = " " THEN 7100
  578. 7090  LOCATE 7,45 : PRINT LEFT$(TT6$+", "+TT8$,34)
  579. 7100  REM get the Husband's Record
  580. 7110  GET #1, TT2
  581. 7120  GOSUB 4550  'Extract
  582. 7130  THIS.PERS = TT2 : GOSUB 9430
  583. 7140  LOCATE 4,11 : COLOR G : PRINT LEFT$(VALUE$,44);
  584. 7150  LOCATE 4,67 : PRINT T8$;
  585. 7160  REM get the Wife's Record
  586. 7170  GET #1, TT3
  587. 7180  GOSUB 4550  'Extract
  588. 7190  THIS.PERS = TT3 : GOSUB 9430
  589. 7200  LOCATE 5,11 : COLOR G : PRINT LEFT$(VALUE$,44);
  590. 7210  LOCATE 5,67 : PRINT T8$;
  591. 7220  REM Blank previous children and find new ones
  592. 7230  FOR IC = 1 TO CHILD.COUNT
  593. 7240   CH(IC) = 0
  594. 7250  NEXT IC
  595. 7260  CHILD.COUNT = 0
  596. 7270  REM search the parent/child index
  597. 7280  REM Establish Skip-ahead Start-value and Delta
  598. 7290  START.AT = 1 : DELTA = INT(PC.COUNT/10) : IF DELTA = 0 THEN 7340
  599. 7300  REM Add delta and test if too far
  600. 7310  START.AT = START.AT + DELTA
  601. 7320  IF START.AT > 9 * DELTA THEN 7340
  602. 7330  IF HUSB > PA.ID(START.AT) THEN 7310
  603. 7340  START.AT = START.AT - DELTA
  604. 7350  REM Search Routine
  605. 7360  FOR LL = START.AT TO PC.COUNT
  606. 7370   IF TT2 > PA.ID(LL) THEN 7760
  607. 7380   IF TT2 < PA.ID(LL) THEN LL = PC.COUNT : GOTO 7760
  608. 7390   REM found a child
  609. 7400   GET #1, CH.ID(LL)
  610. 7410   GOSUB 4550  'Extract
  611. 7420   REM verify that Mother is the same
  612. 7430   IF TT3 <> T7 THEN 7760
  613. 7440   REM Found a valid child
  614. 7450   CHILD.COUNT = CHILD.COUNT + 1
  615. 7460   SHOW.COUNT = CHILD.COUNT
  616. 7470   IF CHILD.COUNT = 1 THEN 7640
  617. 7480   X11 = 0
  618. 7490   X11 = X11 + 11
  619. 7500   IF CHILD.COUNT > X11 THEN SHOW.COUNT = CHILD.COUNT - X11 : GOTO 7490
  620. 7510   IF (CHILD.COUNT-1) MOD 11 = 0 THEN 7520 ELSE 7640
  621. 7520   LOCATE 23,1 : PRINT SPACE$(79);
  622. 7530   LOCATE 23,1
  623. 7540   PRINT "Press p to Print Screen, or any other key to continue"
  624. 7550   A$ = INKEY$ : IF A$ = "" THEN 7550
  625. 7560   IF A$ = "P" OR A$ = "p" THEN GOSUB 7950 : GOTO 7550
  626. 7570   REM blank the previous children
  627. 7580   FOR ROW = 9 TO 20
  628. 7590    LOCATE ROW,2 : PRINT SPACE$(77);
  629. 7600   NEXT ROW
  630. 7610   REM restore the rest of the display
  631. 7620   GOSUB 3110
  632. 7630   LOCATE 23,1 : PRINT SPACE$(79)
  633. 7640   CH(CHILD.COUNT) = CH.ID(LL)
  634. 7650   LOCATE 9+SHOW.COUNT,2 : COLOR K,W
  635. 7660   CC.STR$ = " "+STR$(CHILD.COUNT)
  636. 7670   PRINT RIGHT$(CC.STR$,3); : COLOR G,K
  637. 7680   LOCATE 9+SHOW.COUNT,6 : PRINT LEFT$(F4$,1);  'Sex
  638. 7690   NM$ = T2$+", "+T3$
  639. 7700   IF T2$ = " " OR T3$ = " " THEN NM$ = T2$+T3$
  640. 7710   LOCATE 9+SHOW.COUNT,8 : PRINT LEFT$(NM$,32);
  641. 7720   LOCATE 9+SHOW.COUNT,41 : PRINT T8$;
  642. 7730   IF T9$ = " " AND T11$ = " " THEN 7750
  643. 7740   LOCATE 9+SHOW.COUNT,53 : PRINT LEFT$(T9$+", "+T11$,26);
  644. 7750   COLOR W,K
  645. 7760  NEXT LL
  646. 7770  LOCATE 23,1 : PRINT SPACE$(79);
  647. 7780  LOCATE 24,1 : PRINT SPACE$(79);
  648. 7790  LOCATE 24,1 : PRINT "(Possible Requests: ps, f, m, p1...pn, c1...cn, m1...mn, q)";
  649. 7800  LOCATE 23,1
  650. 7810  LINE INPUT "Type a Request.  Then press the 'enter' key.: "; REPLY$
  651. 7820  IF REPLY$ = "ps" OR REPLY$ = "PS" THEN GOSUB 7950 : GOTO 7770
  652. 7830  IF REPLY$ = "pc" OR REPLY$ = "PC" THEN LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 7770
  653. 7840  IF REPLY$ = "f" OR REPLY$ = "F" THEN PERS(1) = TT2 : GOTO 3950
  654. 7850  IF REPLY$ = "m" OR REPLY$ = "M" THEN PERS(1) = TT3 : GOTO 3950
  655. 7860  IF LEFT$(REPLY$,1) = "p" OR LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 3940
  656. 7870  IF LEFT$(REPLY$,1) = "c" OR LEFT$(REPLY$,1) = "C" THEN 7880 ELSE 7920
  657. 7880  CHLD = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))
  658. 7890  IF CHLD < 1 OR CHLD > CHILD.COUNT THEN 7940
  659. 7900  PERS(1) = CH(CHLD)
  660. 7910  GOTO 3950  'for personal
  661. 7920  IF LEFT$(REPLY$,1) = "m" OR LEFT$(REPLY$,1) = "M" THEN 9220 'marriage
  662. 7930  IF LEFT$(REPLY$,1) = "q" OR LEFT$(REPLY$,1) = "Q" THEN 9350
  663. 7940  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 7770
  664. 7950  REM Routine to Print the Screen
  665. 7960  REM Accessed by users 'ps' reply
  666. 7970  LPRINT : LPRINT : LPRINT : LPRINT
  667. 7980  FOR ROW = 2 TO 20
  668. 7990   FOR COL = 1 TO 79
  669. 8000    X = SCREEN(ROW,COL)
  670. 8010    IF X > 125 THEN X = 32
  671. 8020    IF X < 32 THEN X = 32
  672. 8030    LPRINT CHR$(X);
  673. 8040   NEXT COL
  674. 8050   LPRINT
  675. 8060  NEXT ROW
  676. 8070  LPRINT FORM.FEED$;
  677. 8080  RETURN
  678. 8090  REM Routine to Display the Ordinances
  679. 8100  KEY ON : CLS
  680. 8110  GET #1, PERS(1) : GOSUB 4550
  681. 8120  GET #3, PERS(1)
  682. 8130  SEX$ = " "
  683. 8140  IF T4$ = MALE.SEX$   THEN SEX$ = MALE.LTR$
  684. 8150  IF T4$ = FEMALE.SEX$ THEN SEX$ = FEMALE.LTR$
  685. 8160  REM Extract the Ordinance Information
  686. 8170  U1! = CVS(O1$) : U1 = U1!
  687. 8180  REM Blank Ordinances of no Ordinance Record Present
  688. 8190  IF U1 = 0 THEN GOSUB 9540 : GOTO 8430
  689. 8200  U2$ = O2$
  690. 8210  U3$ = O3$
  691. 8220  U4$ = O4$
  692. 8230  U5! = CVS(O5$) : U5 = U5!
  693. 8240  U6! = CVS(O6$) : U6 = U6!
  694. 8250  U7$ = O7$
  695. 8260  U8$ = O8$
  696. 8270  U9$ = O9$
  697. 8280  U10$ = O10$
  698. 8290  U11$ = O11$
  699. 8300  U12! = CVS(O12$) : U12 = U12!
  700. 8310  U13$ = O13$
  701. 8320  U14$ = O14$
  702. 8330  U15$ = O15$
  703. 8340  U16$ = O16$
  704. 8350  U17$ = O17$
  705. 8360  U18$ = O18$
  706. 8370  U19$ = O19$
  707. 8380  U20$ = O20$
  708. 8390  U21$ = O21$
  709. 8400  U22$ = O22$
  710. 8410  U23$ = O23$
  711. 8420  U24$ = O24$
  712. 8430  KEY OFF
  713. 8440  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 1300  'Double Box
  714. 8450  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 3210  'Horizontal Double
  715. 8460  R1 = 19 : C1 = 1 : R2 = 19 : C2 = 79 : GOSUB 3210  'Horizontal Double
  716. 8470  LOCATE 2,3 : PRINT "Ordinances of:";
  717. 8480  LOCATE 4,7 : COLOR N : PRINT "Personal Record"; : COLOR O
  718. 8490  LOCATE 5,3 : PRINT "Christening:";
  719. 8500  LOCATE 6,3 : PRINT "Blessing:";
  720. 8510  LOCATE 7,3 : PRINT "Sealed to Parents:";
  721. 8520  LOCATE 8,5 : PRINT "Father's Rec.no:";
  722. 8530  LOCATE 9,6 : PRINT "Name:";
  723. 8540  LOCATE 10,5 : PRINT "Mother's Rec.no:";
  724. 8550  LOCATE 11,6 : PRINT "Name:";
  725. 8560  LOCATE 12,3 : PRINT "Baptism:";
  726. 8570  LOCATE 13,3 : PRINT "Confirmation:";
  727. 8580  LOCATE 14,3 : PRINT "Patriarchal Blessing:";
  728. 8590  LOCATE 15,3 : PRINT "Endowment:";
  729. 8600  REM Test for male.  Skip if male.
  730. 8610  IF SEX$ = MALE.LTR$ THEN 8650
  731. 8620  LOCATE 16,3 : PRINT "Sealed to Husband:";
  732. 8630  LOCATE 17,5 : PRINT "Husband's Rec.no:";
  733. 8640  LOCATE 18,6 : PRINT "Name:";
  734. 8650  REM Test for Male.  Skip if not
  735. 8660  IF SEX$ <> MALE.LTR$ THEN 8800
  736. 8670  R1 = 3 : R2 = 19 : C1 = 51 : C2 = 51 : GOSUB 3350  "Vertical Double
  737. 8680  LOCATE 4,57 : COLOR N : PRINT "Priesthood Record"; : COLOR O
  738. 8690  LOCATE 5,53 : PRINT "Aaronic:";
  739. 8700  LOCATE 6,55 : PRINT "Deacon:";
  740. 8710  LOCATE 7,55 : PRINT "Teacher:";
  741. 8720  LOCATE 8,55 : PRINT "Priest:";
  742. 8730  LOCATE 10,53 : PRINT "Melchizedek:";
  743. 8740  LOCATE 11,55 : PRINT "Elder:";
  744. 8750  LOCATE 12,55 : PRINT "Seventy:";
  745. 8760  LOCATE 13,55 : PRINT "High Priest:";
  746. 8770  LOCATE 15,53 : PRINT "Bishop:";
  747. 8780  LOCATE 16,53 : PRINT "Patriarch:";
  748. 8790  LOCATE 17,53 : PRINT "Apostle:";
  749. 8800  LOCATE 20,3  : PRINT "Occupation:";
  750. 8810  REM Print the Information Currently Present
  751. 8820  LOCATE 2,18 : COLOR W : PRINT LEFT$(T3$ + " " + T2$,47);
  752. 8830  LOCATE 2,66 : PRINT "Rec.no:";T1;
  753. 8840  LOCATE 5,28 : COLOR G : PRINT U2$;
  754. 8850  LOCATE 6,28 : PRINT U3$;
  755. 8860  LOCATE 7,28 : PRINT U4$;
  756. 8870  IF SEX$ = MALE.LTR$ THEN NO.SP = 38 ELSE NO.SP = 51
  757. 8880  LOCATE 8,27 : PRINT U5;
  758. 8890  IF U5 = 0 THEN 8920
  759. 8900  GET #1, U5 : GOSUB 4550  'Extract Father Information
  760. 8910  LOCATE 9,12 : PRINT LEFT$(T3$ + " " + T2$,NO.SP);
  761. 8920  LOCATE 10,27 : PRINT U6;
  762. 8930  IF U6 = 0 THEN 8960
  763. 8940  GET #1, U6 : GOSUB 4550  'Extract Mother Information
  764. 8950  LOCATE 11,12 : PRINT LEFT$(T3$ + " " + T2$,NO.SP);
  765. 8960  LOCATE 12,28 : PRINT U7$;
  766. 8970  LOCATE 13,28 : PRINT U8$;
  767. 8980  LOCATE 14,28 : PRINT U9$;
  768. 8990  LOCATE 15,28 : PRINT U10$;
  769. 9000  REM Test for male.  Skip if male.
  770. 9010  IF SEX$ = MALE.LTR$ THEN 9070
  771. 9020  LOCATE 16,28 : PRINT U11$;
  772. 9030  LOCATE 17,27 : PRINT U12;
  773. 9040  IF U12 = 0 THEN 9070
  774. 9050  GET #1, U12 : GOSUB 4550  'Extract Spouse Information
  775. 9060  LOCATE 18,12 : PRINT T3$ + " " + T2$;
  776. 9070  REM Test for Male.  Bypass if not.
  777. 9080  IF SEX$ <> MALE.LTR$ THEN 9200
  778. 9090  LOCATE 5,67 : PRINT U13$;
  779. 9100  LOCATE 6,67 : PRINT U14$;
  780. 9110  LOCATE 7,67 : PRINT U15$;
  781. 9120  LOCATE 8,67 : PRINT U16$;
  782. 9130  LOCATE 10,67 : PRINT U17$;
  783. 9140  LOCATE 11,67 : PRINT U18$;
  784. 9150  LOCATE 12,67 : PRINT U19$;
  785. 9160  LOCATE 13,67 : PRINT U20$;
  786. 9170  LOCATE 15,67 : PRINT U21$;
  787. 9180  LOCATE 16,67 : PRINT U22$;
  788. 9190  LOCATE 17,67 : PRINT U23$;
  789. 9200  LOCATE 20,15 : PRINT U24$;
  790. 9210  GOTO 4380  'For User Action
  791. 9220  REM Marriage was requested by Number
  792. 9230  MARRIAGE = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))
  793. 9240  KEY ON : CLS : KEY OFF
  794. 9250  IF MARRIAGE > 0 AND MARRIAGE <= MAX.MAR THEN 9320
  795. 9260  LOCATE 22,1 : PRINT SPACE$(79);
  796. 9270  LOCATE 22,1 : PRINT "Invalid Marriage Number";
  797. 9280  LOCATE 23,1 : PRINT SPACE$(79);
  798. 9290  LOCATE 23,1 : PRINT "Press any key to continue."
  799. 9300  A$ = INKEY$ : IF A$ = "" THEN 9300
  800. 9310  GOTO 3950
  801. 9320  GOSUB 2970  'Print the form
  802. 9330  GET #2, MARRIAGE
  803. 9340  GOTO 6870
  804. 9350  REM Wrapup
  805. 9360  CLOSE #1
  806. 9370  CLOSE #2
  807. 9380  IF DD.ORD$ = "no" THEN 9400
  808. 9390  CLOSE #3
  809. 9400  KEY ON : CLS : KEY OFF : LOCATE 21,1 : COLOR W,K
  810. 9410  PRINT "End of Program"
  811. 9420  RUN DD.MENU$+"menu"
  812. 9430  REM Routine to Convert a number to a string.  This.pers is input
  813. 9440  REM value$ is output, with record number and persons name.
  814. 9450  VALUE$ = STR$(THIS.PERS)
  815. 9460  WIDE = LEN(VALUE$)
  816. 9470  VALUE$ = RIGHT$(VALUE$,WIDE-1)
  817. 9480  NM$ = T2$+", "+T3$
  818. 9490  IF T2$ = " " OR  T3$ = " " THEN NM$ = T2$+T3$
  819. 9500  IF T2$ = " " AND T3$ = " " THEN NM$ = ""
  820. 9510  IF CHART.NOS$ <> "n" THEN VALUE$ = NM$ : GOTO 9530
  821. 9520  VALUE$ = "("+VALUE$+") "+NM$
  822. 9530  RETURN
  823. 9540  REM Blank Ordinances if No Ord Record
  824. 9550  U2$  = "" : U3$  = "" : U4$  = ""
  825. 9560  U5   = 0  : U6   = 0  : U12  = 0
  826. 9570  U7$  = "" : U8$  = "" : U9$  = "" : U10$ = ""
  827. 9580  U11$ = "" : U13$ = "" : U14$ = "" : U15$ = ""
  828. 9590  U16$ = "" : U17$ = "" : U18$ = "" : U19$ = ""
  829. 9600  U20$ = "" : U21$ = "" : U22$ = "" : U23$ = ""
  830. 9610  U24$ = ""
  831. 9620  RETURN
  832.